Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue48/Memory/APIProg.dpr

Text File | 1999-06-23 | 7.5 KB | 276 lines

program APIProg;

{$ifdef Ver90} { Delphi 2.0x }
  {$define DelphiLessThan3}
  {$define DelphiLessThan4}
{$endif}
{$ifdef Ver93} { C++ Builder 1.0x }
  {$define DelphiLessThan3}
  {$define DelphiLessThan4}
{$endif}
{$ifdef Ver100} { Delphi 3.0x }
  {$define DelphiLessThan4}
{$endif}

{$ifdef Windows}
  'Win32 application only'
{$endif}

//Link in custom resources. Note the difference between the
//resource file name and the project name. If you make them the
//same, Delphi will overwrite the RES file with its own one.
{$R API_Prog.Res}

uses
  Windows, Messages;

const
  idm_About = 100;
  idm_Test = 101;
  id_Flash = 57;

function Gasp(Wnd: HWnd): Boolean;
var
  Msg: TMsg;
begin
  Result := True;
  { While we have messages to process, process them }
  while PeekMessage(Msg, 0, 0, 0, pm_Remove) do
  begin
    { Except Quit, of course }
    if Msg.Message = wm_Quit then
    begin
      { In which case post another quit message for }
      { the main message loop to catch, and thus exit }
      PostQuitMessage(Msg.WParam);
      { Return False so caller can break out of processing loop }
      Result := False;
      { Bail out }
      Break;
    end;
    { Translate virtual key messages into character messages }
    TranslateMessage(Msg);
    { Send message to relevant window }
    DispatchMessage(Msg);
  end;
end;

function CommittedMemorySize: DWord;
var
  MBI: TMemoryBasicInformation;
  SI: TSystemInfo;
  RangeStart: Pointer;
begin
  Result := 0;
  GetSystemInfo(SI);
  RangeStart := SI.lpMinimumApplicationAddress;
  while DWord(RangeStart) < DWord(SI.lpMaximumApplicationAddress) do
  begin
    VirtualQuery(RangeStart, MBI, SizeOf(MBI));
    //Only get committed memory (storage allocated for this)
    if MBI.State = MEM_COMMIT then
      Inc(Result, MBI.RegionSize);
    //Delphi 2 & 3 could only handle $7FFFFFFF as biggest int
    //Last region is likely to end at $80000000. To avoid integer
    //overflow, we'll do a comparison and bypass the addition
    if DWord(SI.lpMaximumApplicationAddress)-MBI.RegionSize >= DWord(RangeStart) then
      Inc(PChar(RangeStart), MBI.RegionSize)
    else
      //If overflow would have occurred, loop is over
      Break
  end;
end;

function About(Dialog: HWnd; Msg, WParam: Word;
  LParam: Longint): Bool; {$ifdef Win32}stdcall{$else}export{$endif};
var
  Loop: Word;
begin
  About := True;
  case Msg of
    wm_InitDialog:
      Exit;
    wm_Command:
      case WParam of
        id_Ok, id_Cancel:
          begin
            EndDialog(Dialog, WParam);
            Exit;
          end;
        id_Flash:
          begin
            for Loop := 1 to 5000 do
            begin
              { EndDialog hides the window, but doesn't destroy it }
              { until the dialog procedure finishes. When asked to }
              { close we ought to stop doing our stuff }
              if not IsWindowVisible(Dialog) then
                Break;
              FlashWindow(Dialog, True);
              Gasp(Dialog);
            end;
            Exit;
          end;
      end;
  end;
  About := False;
end;

function WindowProc(Window: HWnd; Msg, WParam: Word;
  LParam: Longint): Longint; {$ifdef Win32}stdcall{$else}export{$endif};
var
  AboutProc: TFarProc;
  Loop: Longint;
  DC: HDC;
  Rect: TRect;
  OldPen: HPen;
  CaptionStr: String;
begin
  WindowProc := 0;
  case Msg of
    wm_Command:
      case WParam of
        idm_About:
          begin
            AboutProc := MakeProcInstance(@About, HInstance);
            DialogBox(HInstance, 'AboutBox', Window, AboutProc);
            FreeProcInstance(AboutProc);
            Exit;
          end;
        idm_Test:
          begin
            for Loop := 1 to 1000 do
            begin
              if not Gasp(Window) then
                Break;
              GetClientRect(Window, Rect);
              DC := GetDC(Window);
              OldPen := SelectObject(DC, CreatePen(ps_Solid, Random(11),
                RGB(Random(256), Random(256), Random(256))));
              MoveToEx(DC, Random(Rect.Right), Random(Rect.Bottom), nil);
              LineTo(DC, Random(Rect.Right), Random(Rect.Bottom));
              DeleteObject(SelectObject(DC, OldPen));
              ReleaseDC(Window, DC);
            end;
            Exit;
          end;
      end;
    wm_Timer:
      begin
        Str(CommittedMemorySize div 1024, CaptionStr);
        CaptionStr := CaptionStr + ' kilobytes';
        SetWindowText(Window, PChar(CaptionStr))
      end;
    wm_Destroy:
      begin
        PostQuitMessage(0);
        Exit;
      end;
  end;
  WindowProc := DefWindowProc(Window, Msg, WParam, LParam);
end;

procedure WinMain;
var
  Window: HWnd;
  Msg: TMsg;
  AccelTbl: THandle;
const
  AppName = 'Generic';
  WindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @WindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: AppName;
    lpszClassName: AppName);
begin
  if HPrevInst = 0 then
  begin
    WindowClass.hInstance := HInstance;
    WindowClass.hIcon := LoadIcon(0, idi_Application);
    WindowClass.hCursor := LoadCursor(0, idc_Arrow);
    WindowClass.hbrBackground := GetStockObject(white_Brush);
    if not Bool(RegisterClass(WindowClass)) then
      Halt(255);
  end;
  AccelTbl := LoadAccelerators(HInstance, AppName);
  Window := CreateWindow(
    AppName,
    nil,
    ws_OverlappedWindow,
    Integer(cw_UseDefault),
    Integer(cw_UseDefault),
    Integer(cw_UseDefault),
    Integer(cw_UseDefault),
    0,
    0,
    HInstance,
    nil);
  SetTimer(Window, 1, 100, nil);
  ShowWindow(Window, CmdShow);
  UpdateWindow(Window);
  while GetMessage(Msg, 0, 0, 0) do
    if TranslateAccelerator(Window, AccelTbl, Msg) = 0 then
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  Halt(Msg.wParam);
end;

(* // Windows 95/98 version
procedure RemoveExcessDLLs;
begin
  //Stop the RTL wanting to clear System Variants
{$ifndef DelphiLessThan4}
  TVarData(EmptyParam).VType := varEmpty;
{$endif}
  //These two seem to be considered constants, so we hack around
  //this by de-referencing the "constant" item's address
  TVarData((@Null)^).VType := varEmpty;
  TVarData((@Unassigned)^).VType := varEmpty;
  //Unload OLEAUT32.DLL, which will in turn unload OLE32.DLL
  FreeLibrary(GetModuleHandle('OLEAUT32.DLL'));
end; *)

// Windows NT version
procedure ReduceMemoryOverhead;
var
  ProcessHandle: THandle;
  OSVersionInfo: TOSVersionInfo;
begin
  //Stop the RTL wanting to clear System Variants
{$ifndef DelphiLessThan4}
  TVarData(EmptyParam).VType := varEmpty;
{$endif}
  //These two seem to be considered constants, so we hack around
  //this by de-referencing the "constant" item's address
  TVarData((@Null)^).VType := varEmpty;
  TVarData((@Unassigned)^).VType := varEmpty;
  //Unload OLEAUT32.DLL, which will in turn unload OLE32.DLL
  FreeLibrary(GetModuleHandle('OLEAUT32.DLL'));

  OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
  if GetVersionEx(OSVersionInfo) and (OSVersionInfo.dwPlatformID = VER_PLATFORM_WIN32_NT) then
  begin
    ProcessHandle := OpenProcess(PROCESS_ALL_ACCESS, False, GetCurrentProcessID);
    //Remove any unimportant code/data from memory
    SetProcessWorkingSetSize(ProcessHandle, -1, -1);
    CloseHandle(ProcessHandle);
  end
end;

begin
{$ifndef DelphiLessThan3}
  if ParamCount > 0 then
    ReduceMemoryOverhead;
{$endif}
  Randomize;
  WinMain;
end.